perm filename NOTBMS.F4[NEW,LCS]15 blob
sn#337804 filedate 1978-02-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C***** SUBRS NOTES, TYPOUT, MISMCH, MARKS ***********
C00024 ENDMK
C⊗;
C***** SUBRS NOTES, TYPOUT, MISMCH, MARKS ***********
SUBROUTINE NOTES
COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
1 /XRN/RN(1)
1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,
1 IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA /ALF/CLF,JQX,D,
1 KQ,JG,X,ACC,STMDR,Y,LL,RZ,RC,INP(61) /POS/POS1,POS2,R4
1 /FRMT/F78F(1),FA1(1),FA5(1),ASK
1 /RINP/R(10,85),RPOS(2,50) /RMOD/RMODE2,SET4,IBEAM,
1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,ITB,POSB
DATA ACMV/2.3/
RMODE=0
IF(RMODE2.GE.500)RMODE=RMODE2
C RMODE2≥500 IS FOR USER-ADDED NOTE AND REST ROUTINE (SUBR EXTRA)
CP POS1=0
CP POS2=200
STFLG=0
GO TO 111
CCC444 FORMAT(' TYPE POS1, POS2, (SPC) '$)
444 SET4=RA
111 FORMAT(A2,F)
CALL SETUP
IF(STUP.GE.0)GO TO 8
CC IF(ST(3601).GE.0)GO TO 8
C ST(3601) IS LOC. OF RPOS(1,1)
C SKIPS IF USING SETUP ON SOME STAFF
IF(POS2.NE.0)GO TO 4334
C JUMP IF POS1, POS2, ETC. WERE SET UP IN FILE (* SP ST POS1 POS2 X)
CCC4333 TYPE 444
4333 CALL TYPSTR('TYPE POS1, POS2, (SPC) ')
ACCEPT F78F,POS1,POS2,R4
C DON'T USE INVIS. RESTS WITH SPACING FEATURE!!!!
REREAD 111,K,RA
IF(K.EQ.'SP')GO TO 444
C TYPE "SPn" TO SET SPACING STAFF AT THIS POINT.
IF(POS2.EQ.0)POS2=200.
IF(POS1.GE.POS2)GO TO 4333
C TYPE ANY POSITIVE 3RD NUM. FOR PSUEDO-FIBONACCI SPACING OF RHYTH.
4334 STUP=STUP-R4
8 KN=0
IRHY=0
C IZ=# OF ITEMS FROM SCANR*******
IZ=I-1
C LIMIT OF 100 ITEMS***** 4/74 *****
CLF=0
KCLF=0
JCLF=0
C DEFAULT IS ALWAYS TREBLE CLEF
IF(POS2.NE.0)GO TO 71
POS2=200
71 K=IZ+1
DO 70 KQ=1,IZ
X=V(KQ)
IF(X.GE.0)GO TO 70
IF(-X.LT.2000)K=K-1
C TO GET THE RIGHT ITEM COUNT WITH CHORDS, ETC.
70 CONTINUE
D=(POS2-POS1)/K
C D WILL SPACE ALL ITEMS EVENLY FOR NOW
STEM=-1
C K=COUNTER FOR USEFUL ITEMS (OMITS CLEFS)
K=1
KQ=1
C LOOPS TO 7333
7 JG=-1
X=V(KQ)
C notes = 1xyz.0 x=accidental, yz=note num., negative=chord note
C rest = 2xyz.0 z=0=ordinary, =1=invis., =2=whole, =3=repeat bar
C =4=down, =5=up, -2xyz=num. of meas. rest
C clefs = 3xyz.0 z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
C bars = 4xyz.0 z=num. of staves up, neg.=dbl.bar
C ksig = 17xyz.0 z=num. of accis., pos.=#, neg.=b
C meter = 18xyz.n xy=top num, zn=bottom num (DONE IN SCMSS)
C stem = 5xyz.0 YZ=10=stem up, =20=stem down
C staff = 5xyz.0 z=0=return to norm., =1=lower stf., =2=upper stf.
IF(X)GO TO 27
C NEXT SORTS OUT ORDER OF CHORD
RZ=V(KQ+1)
IF(RZ.GT.0)GO TO 27
IF(ABS(RZ).GE.2000)GO TO 27
C SKIPS NON-NOTES
327 RZ=AMOD(X,100.0)
57 LL=KQ
Y=0
RA=RZ
37 LL=LL+1
STMDR=RA
RA=-V(LL)
IF(RA)GO TO 27
C EXITS WITH NON-NOTES OR NON-CHORD NOTES.
RA=AMOD(RA,100.0)
C GETS RID OF ACCI. FOR NOW
IF(RA.GE.99)GO TO 27
IF(Y)127,97,67
C Y IS STEM DIRECTION. -1=DOWN, 1=UP
97 Y=RA-STMDR
GO TO 37
67 IF(RA.LT.RZ)V(LL)=V(LL)-7
C TRAP FOR NOTE IN WRONG OCT. (CONFUSES STEM DIRECTION.)
IF(RA.GE.STMDR)GO TO 37
227 CALL EXCH(V(LL),V(LL-1))
C NOW START OVER AGAIN
GO TO 57
127 IF(RA.GT.RZ)V(LL)=V(LL)+7
IF(STMDR.GT.RA)GO TO 37
GO TO 227
27 R4=0
R5=0
R6=0
R8=0
DO 89 LL=2,10
89 R(LL,K)=0
C TO CLEAR END OF ITEM
KODE=ABS(X)/1000
IF(X.LT.0.AND.KODE.NE.2)GO TO 86
C JUMP IF A CHORD NOTE, CLEF OR BAR OR METER
IF(KODE.LE.2)IRHY=IRHY+1
C ADDS A RHYTHMIC UNIT
C TO CLEAR LAST PARAMS IN SOME ITEMS LATER
86 GO TO (21,22,23,24,25),KODE
IF(KODE.EQ.17)GO TO 1700
C NEXT IS FOR METERS
L=(X-18000.)/10
R5=L
C GETS TOP NUM OF METER
R6=AMOD(X,10.0)*10.0+.01
GO TO 843
23 CLF=ABS(X)-3000.
JCLF=CLF
IF(X)GO TO 871
C IS THE CLEF INVISIBLE?
R5=CLF
IF(KCLF)R4=R4+100
C MINI CLEF AFTER 1ST REGULAR SIZE.
KCLF=-1
GO TO 843
25 Y=X-5000
IF(Y.LT.10)GO TO 250
C NEXT FOR STEM UP, DOWN
C DOWN = 20 (5020), UP=10 (5010)
STEM=Y
GO TO 871
250 STFLG=Y
C STAFF ABOVE=2, BELOW=1, RESET=0
GO TO 871
24 R4=ABS(X)-4000
CALL NOZERO(R4)
IF(X)R4=R4+1500
C NEG =DBL BAR.
GO TO 843
1700 R5=ABS(X)-17000.
C KEY SIGS NEG=FLATS
IF(X)R5=-R5
R6=CLF
GO TO 843
22 Y=ABS(X)-2000
IF(X)GO TO 831
IF(Y.EQ.0)GO TO 843
C ORDINARY REST=0
IF(Y.LT.4)GO TO 882
C REST UP=5, DOWN=4
R4=6
IF(Y.EQ.4)R4=-R4
GO TO 843
882 IF(Y.EQ.1)GO TO 885
IF(Y.EQ.2)GO TO 886
C NEXT FOR CENTERED REPEAT SIGN
R8=-5
CQQ R5=-4
GO TO 843
CQQ GO TO 887
CC885 R8=9999
885 R6=-2
C ↑↑ FOR INVIS. REST (FIRST YOU SEE IT, THEN YOU DON'T.)
GO TO 843
886 R8=-1
C ↑ FOR WHOLE REST (ANY RHYTHM)
CC887 R(9,K)=-1
GO TO 843
831 R8=Y
C NUMS OF BARS REST
CQQ GO TO 887
GO TO 843
21 R(10,K)=STFLG
IF(X.GT.0)GO TO 210
X=-X
R8=-1
C CHORD NOTE
JG=0
210 LL=X-1000
C NOTES
L=LL/100
C THE ACCI.
R5=L
N=MOD(LL,100)-1
C THE NOTE NUM.
L=N/7
C OCT. NUM HERE IS 1 .GT. THAN THAT TYPED. (OCT. 0 IS POSSIBLE NOW.)
N=MOD(N,7)+1
C ABSOLUTE NOTE NUM.
KA=JCLF*12
C THIS WILL ADJUST FOR CLEF NUM.
IF(JCLF.GE.2)KA=JCLF*2+2
R4=(L-4)*7+KA+N
STMDR=10.
IF(R4.GE.7)STMDR=20.
CO IF(STEM.GT.0)STMDR=STEM
IF(STEM.LE.0)GO TO 26
STMDR=STEM
C SHORTEN STEMS WHEN TURNED TO NON-STANDARD DIRECTION.
CCC NO NO NO -- THIS USED ESLWHERE. R8=-1
C FOR STEM DIRECTIONS - 'B' AND HIGHER HAVE STEMS DOWN.
CO IF(JG)GO TO 3133
C JUMP IF NOT DBLSTOP
26 IF(JG.GE.0)GO TO 6
C NEXT LENGTHENS STEMS FOR VERY HIGH OR VERY LOW NOTES.
IF(STMDR.EQ.20)GO TO 16
C NEXT FOR STEM UP
IF(R4.LT.0)R8=-R4
C STEMS OF VERY HIGH OR VERY LOW NOTES WILL ALWAYS TOUCH MIDDLE LINE
GO TO 3133
16 IF(R4.GT.14)R8=R4-14
C SEE 'BEAMS' AT 143 FOR SIMILAR FEATURE
GO TO 3133
6 L=K-1
IF(R(5,L).GE.10.)MX=L
C MX=1ST NOTE OF CHRD
STMDR=0
L=K-MX
IF(R4.LT.R(4,MX))L=-L
R(7,MX)=L
C L+=STEM UP, L-=STEM DOWN ... USED AT END OF NOTES.
X=ABS(R(4,MX)-R4)-1.
C EXTENDS THE STEM!
C AFTER 1ST NOTE, ORDER MAY BE SCRAMBLED IN CHORDS. STEM OK.
IF(X.LT.1.)X=1.
IF(R(8,MX).LT.X)R(8,MX)=X
3133 R5=R5+STMDR
843 R(4,K)=R4
R(5,K)=R5
R(6,K)=R6
R(8,K)=R8
CS R(2,K)=STAFF
IF(JG)KN=KN+1
R(3,K)=KN*D+POS1
R(1,K)=KODE
87 K=K+1
871 KQ=KQ+1
IF(KQ.LE.IZ)GO TO 7
IZ=K-1
C IZ IS NOW REALLY THE NUMBER OF ITEMS TO BE PROCESSED
C NEXT ADJUSTS PLACEMENT OF ACCIDENTALS AND 2NDS.
K=1
1 RX=R(7,K)
IF(RX.EQ.0)GO TO 2
IF(R(1,K).EQ.2.)GO TO 2
C JUMP IF NO CHRD COMING
IF(RX.GT.0)GO TO 3
C JUMP IF STEM IS UP
RA=R(5,K)
IF(RA.LT.10)GO TO 277
IF(RA.LT.20.)R(5,K)=RA+10.
C PUTS STEM DOWN IF IT WASN'T
277 L=K-RX
C RX=TOTAL(-1) NOTES IN CHORD
R(7,K)=0
4 RA=R(4,K)
RC=0
C INTERVAL TO PREVIOUS NOTE
C CHECK ON USE OF N ELSEWHERE
N=K+1
IF(K.LT.L)RC=RA-R(4,N)
C INTERVAL TO NEXT NOTE
IF(RC+R(6,K).EQ.1.)R(6,N)=20
C PUSHES NOTE TO LEFT
5 K=N
IF(K.GT.L)GO TO 220
GO TO 4
3 DO 30 M=2,IZ
L=M-1
IF(R(4,M)-R(4,L)+R(6,L).NE.1.)GO TO 30
IF(R(3,M).NE.R(3,L))GO TO 30
R(6,M)=10
R(6,L)=30
30 CONTINUE
C TO HELP DOTTED NOTES.
C MOVES NOTE TO RIGHT OF STEM WHEN 2ND.
C THE STEM IS UP
RA=R(5,K)
IF(RA.GE.20.)R(5,K)=RA-10.
C PUTS STEM UP IF IT WASN'T
R(7,K)=0
K=1+K+RX
220 CALL ACSHFT(RX)
C L=K-1=END OF CHORD; L-ABS(RX)=START OF CHORD; +RX=↑ -RX=↓
GO TO 222
2 K=K+1
222 IF(K.LE.IZ)GO TO 1
R(1,K)=0
END
SUBROUTINE TYPOUT
COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,
1 IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA /ALF/INP(72),ML
DO 1 KK=72,1,-1
1 IF(INP(KK).NE.IBLA)GO TO 2
CCC2 TYPE 3,MODE,(INP(J),J=1,KK)
CCC3 FORMAT(I2,4X,72A1)
C PERHAPS THE OLD WAY IS BETTER*****
2 CALL TYPINT(MODE)
CALL TYPCHR(' ',3)
DO 3 KKK=1,KK
3 CALL TYPCHR(INP(KKK),1)
CALL TYPCRLF
END
SUBROUTINE MISMCH(RA,Y)
CCC134 FORMAT(' **** MISMATCH WITH SPACING STAFF ****',F7.3/
CCC 1 F7.3,' QUARTERS IN THIS LINE.')
CCC TYPE 134,RA,Y
CALL TYPCRLF
CALL TYPSTR('**** MISMATCH WITH SPACING STAFF ****')
CALL TYPFLT(RA)
CALL TYPCRLF
CALL TYPFLT(Y)
CALL TYPSTR(' QUARTERS IN THIS LINE.')
CALL TYPCRLF
END
SUBROUTINE MARKS(RA)
COMMON/ALF/INP(72),ML
DIMENSION MKS(14)
DATA MKS/'W','A','F','S','M','T','D','U','H','I','P','C','R','O'/
EQUIVALENCE (MF,MKS(3)),(MH,MKS(9)),(MP,MKS(11)),(MM,MKS(5))
1,(MC,MKS(12)),(MR,MKS(13)),(MI,MKS(10)),(MS,MKS(4))
RA=99
DO 16 JM=1,72
16 IF(INP(JM))GO TO 17
C DIDN'T FIND MORE LETTERS
RETURN
17 N=INP(JM)
ML=INP(JM+1)
M=INP(JM+2)
DO 1 K=1,14
1 IF(N.EQ.MKS(K))GO TO 2
C DID NOT FIND A LETTER
RETURN
C 4=W(EDGE),5=A(CCENT),26=FE(RMATA),7=S(TACCATO),9=T(ENUTO)
C 11=D(OWNBOW), 12=U(PBOW),13=H(ARMONIC),14=PL(US),15=TH(ESIS)
C 16=AR(SIS),17=MO(RDANT)
C 18=I(NVRTD MORD), ---,20=TR(ILL), 21=TRF(LAT), 22=TRS(HARP)
C 23=TRN(ATURAL), >39=PPP, PP, CRESC., ETC.
C 25=HW (HEAVY WEDGE), 80=ACC(EL.) FICTA:5=FLAT, 2=#, 3=NAT.
C***** 20 IS OPEN
2 GO TO(120,10,12,120,4,11,15,15,15,21,12,80,81,87),K
12 IF(ML.EQ.'L')GO TO 120
C ↑↑↑ PLUS
IF(N.EQ.MF)GO TO 121
RA=42
IF(ML.NE.MP)GO TO 18
RA=41
IF(M.EQ.MP)RA=40
C FOR P, PP, PPP -- 42, 41, 40
GO TO 18
15 IF(ML.EQ.MI)GO TO 82
K=K+1
IF(ML.EQ.MKS(1))K=22
C 'HW' MAKES 25 (EVENTUALLY MAKES CLEF# 44)
120 IF(ML.EQ.MF)GO TO 88
K=K+3
8 RA=K
C YOU CAN TYPE # OR NAME OF MARK
18 DO 6 JM=1,72
N=INP(JM)
INP(JM)=' '
C BLANKS OUT USED LETTERS
IF(N.EQ.'/')RETURN
IF(N.EQ.'*')RETURN
6 IF(N.EQ.';')RETURN
4 IF(ML.EQ.'O')GO TO 20
RA=43
IF(ML.EQ.MF)RA=50
C ↑↑↑↑↑ MP, MF
GO TO 18
121 IF(ML.EQ.'E')GO TO 120
C ↑↑↑ FERMATA
RA=51
IF(ML.EQ.MF)RA=52
IF(ML.EQ.MP)RA=54
IF(M.EQ.MF)RA=53
C F, FF, FFF, FP -- 51, 52, 53, 54 --- SF=45, SFZ=92
IF(ML.NE.MI)GO TO 22
C TYPE FIF, FIS, FIN FOR FICTA flat, sharp, natural
RA=1
IF(M.EQ.MS)RA=2
IF(M.EQ.'N')RA=3
GO TO 18
22 M=NALF(ML)
IF(M)GO TO 18
IF(M.LE.5)RA=30+M
C TYPE /2 F0/6 F5/ FOR FINGERING NUMS. 0-5
GO TO 18
88 RA=45
C FOR SF AND SFZ
IF(INP(JM+2).EQ.'Z')RA=92
GO TO 18
10 IF(ML.EQ.MC)GO TO 84
IF(ML.NE.MR)GO TO 120
19 K=13
C 'R' FOR ARSIS
GO TO 120
11 IF(ML.EQ.MH)K=12
C THESIS
IF(ML.NE.MM)GO TO 110
K=60
IF(M.EQ.'E')K=58
IF(M.EQ.MS)K=59
C TM=TREMOLO,3 BEAMS=63 AT LABEL 8
C TME, TMS: 61=1 BEAM, 62=2 BEAMS
110 IF(ML.NE.MR)GO TO 120
K=17
C TR(ILL)=20 TRF(LAT)=21 TRS(HARP)=22 TRN(ATRL)=23
IF(M.EQ.MF)K=18
IF(M.EQ.MS)K=19
IF(M.EQ.'N')K=20
GO TO 120
20 K=17
GO TO 8
21 K=18
GO TO 8
80 IF(ML.EQ.'+')GO TO 85
C FOR /N1 C+ N2/ ETC. -- CRESC. AND DECRESC. LINES.
IF(ML.EQ.'-')GO TO 86
RA=70
C CRESC.
GO TO 18
85 RA=200
GO TO 18
86 RA=199
GO TO 18
87 RA=208
GO TO 18
C ↑↑↑ FOR /N1 OT N2/ 8va
81 RA=37
C RIT.
GO TO 18
82 RA=82
C DIM.
GO TO 18
84 RA=80
C ACCEL.
GO TO 18
END